Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue40/COMCorn/UtilObjs.pas

Pascal/Delphi Source File | 1998-11-10 | 5.6 KB | 220 lines

unit UtilObjs;

interface

uses Windows, Classes, ShlObj, ActiveX, ComObj;

type
  // Class which contains the IEnumIDList implementation for the
  // main TComNameExt class.  This implementation is aggregated to
  // TComNameExt using the implements directive.
  TComServerList = class(TList) { IEnumIDList }
  private
    FCurrent: Integer;
    FOwner: TComObject;
    FShellMalloc: IMalloc;
  public
    constructor Create(Owner: TComObject);
    procedure AddGuid(const Item: TGUID); virtual;
    procedure Clear; override;
    { IEnumIDList methods }
    function Next(celt: ULONG; out rgelt: PItemIDList;
      var pceltFetched: ULONG): HResult; stdcall;
    function Skip(celt: ULONG): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out ppenum: IEnumIDList): HResult; stdcall;
  end;

  // Base class which implements IUnknown for classes that are dispensed
  // by TComNameExt when multiple instances of an interface are required.
  // For example, IShellView, IContextMenu, and IExtractIcon are
  // implemented using a derivative of this class.
  TMultiAggregatedObject = class(TInterfacedObject, IUnknown)
  private
    FController: TComObject;
  protected
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
  public
    constructor Create(Controller: TComObject); virtual;
    destructor Destroy; override;
    property Controller: TComObject read FController;
  end;

  // TSHItemID-type record which is specific to this implementation
  PServInfo = ^TServInfo;
  TServInfo = record  { TSHItemID }
    Size: Word;
    CLSID: TGUID;
  end;

// Helper functions to create and delete reg keys & values

procedure CreateRegKeyEx(const Key, ValueName: string; Value: PChar;
  Kind, Size: DWORD; RootKey: HKEY);

procedure DeleteRegValue(const Key, ValueName: string; RootKey: HKEY);

implementation

uses SysUtils;

procedure CreateRegKeyEx(const Key, ValueName: string; Value: PChar;
  Kind, Size: DWORD; RootKey: HKEY);
var
  Handle: HKey;
  Status, Disposition: Integer;
begin
  Status := RegCreateKeyEx(RootKey, PChar(Key), 0, '',
    REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE or KEY_SET_VALUE, nil,
      Handle, @Disposition);
  if Status = 0 then
  begin
    Status := RegSetValueEx(Handle, PChar(ValueName), 0, Kind, Value, Size);
    RegCloseKey(Handle);
  end;
  if Status <> 0 then raise EWin32Error.Create(SysErrorMessage(Status));
end;

procedure DeleteRegValue(const Key, ValueName: string; RootKey: HKEY);
var
  Handle: HKEY;
  Status: Integer;
begin
  Status := RegOpenKey(RootKey, PChar(Key), Handle);
  if Status = 0 then
  begin
    Status := RegDeleteValue(Handle, PChar(ValueName));
    RegCloseKey(Handle);
  end;
  if Status <> 0 then raise EWin32Error.Create(SysErrorMessage(Status));
end;

{ TComServerList }

constructor TComServerList.Create(Owner: TComObject);
begin
  FOwner := Owner;
  inherited Create;
  OleCheck(SHGetMalloc(FShellMalloc));
end;

procedure TComServerList.AddGuid(const Item: TGUID);
var
  Guid: PGUID;
begin
  GetMem(Guid, SizeOf(TServInfo));
  Guid^ := Item;
  Add(Guid);
end;

procedure TComServerList.Clear;
var
  I: Integer;
  Item: Pointer;
begin
  for I := 0 to Count - 1 do
  begin
    Item := Items[I];
    if Item <> nil then FreeMem(Item);
  end;
  inherited Clear;
end;

{ TComServerList.IEnumIDList }

function TComServerList.Clone(out ppenum: IEnumIDList): HResult;
begin
  Result := E_NOTIMPL;
end;

function TComServerList.Next(celt: ULONG; out rgelt: PItemIDList;
  var pceltFetched: ULONG): HResult;
var
  NewList: PServInfo;
  IDPtr: ^PItemIDList;
begin
  try
    rgelt := nil;
    if @pceltFetched <> nil then pceltFetched := 0
    // pceltFetched can only be nil when celt is 1
    else if celt > 1 then
    begin
      Result := E_POINTER;
      Exit;
    end;
    // Already at the end of the enumeration
    if FCurrent = Count then
    begin
      Result := S_FALSE;
      Exit;
    end;
    IDPtr := @rgelt;  // Keep pointer to walk array
    // Iterate through array, assigning a newly allocated record to each element
    while (celt > 0) and (FCurrent < Count) do
    begin
      NewList := FShellMalloc.Alloc(SizeOf(TServInfo));
      NewList.Size := SizeOf(TServInfo);
      NewList.CLSID := PGUID(List[FCurrent])^;
      IDPtr^ := PItemIDList(NewList);
      Dec(celt);
      Inc(FCurrent);
      Inc(IDPtr);
      if @pceltFetched <> nil then Inc(pceltFetched);
    end;
    Result := S_OK;
  except
    on E: TObject do
      Result := FOwner.SafeCallException(E, ExceptAddr);
  end;
end;

function TComServerList.Reset: HResult;
begin
  Result := S_OK;
  FCurrent := 0;
end;

function TComServerList.Skip(celt: ULONG): HResult;
begin
  Result := S_OK;
  try
    Inc(FCurrent, celt);
    if FCurrent >= Count then FCurrent := Count - 1;
  except
    on E: TObject do
      Result := FOwner.SafeCallException(E, ExceptAddr);
  end;
end;

{ TMultiAggregatedObject }

constructor TMultiAggregatedObject.Create(Controller: TComObject);
begin
  FController := Controller;
  inherited Create;
  (FController as IUnknown)._AddRef;
end;

destructor TMultiAggregatedObject.Destroy;
begin
  (FController as IUnknown)._Release;
  inherited Destroy;
end;

{ TMultiAggregatedObject.IUnknown }

function TMultiAggregatedObject.QueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  try
    Result := inherited QueryInterface(IID, Obj);
    if Result <> S_OK then
      Result := (FController as IUnknown).QueryInterface(IID, Obj);
  except
    Result := E_UNEXPECTED;
  end;
end;

end.